
; 
; Minimalistic test system to test the opcodes of the VM on as low a level as possible
;
;   Based on scheme/debug/low-test.scm
;
;   The idea is to have as few code before/outside of the actual tests as possible
;   so errors in the VM get detected in the test themselves rather than in the
;   code that sets up the testing (which would be harder to track down)
;
;   Every VM instruction should be executed atleast once in these tests.
;
;   Use 'make scheme/vm/vm-test.image' to build the test suite
;


(define (start arg in in-encoding out out-encoding error-out error-out-encoding resumer-records)
  (setup-system in out)

  (call-tests)
  (compare-tests)
  (predicate-tests)  
  (math-tests)
  (stob-tests)  
  (misc-tests)  
  (thread-tests)
  (io-tests)
  (external-tests)

  (report-results))
  
; ------------------  test system   -------------------------------

(define *tests-run*  0)
(define *failures*   0)
(define *exceptions* 0)

(define-syntax define-test-suite
  (syntax-rules ()
    ((define-test-suite name name-string thunk)
     (define (name)
       (newline)
       (write-string "------------------------------ Testing: ")
       (write-string name-string)
       (write-string " ------------------------------")
       (newline)
       (newline)
       (thunk)))))

;
; if operator is specified in the test macros, they create 
; both a normal and a closed-compiled version of the test
;

; check for the correct result with =
;
(define-syntax arith-test
  (syntax-rules ()
    ((arith-test value name expected)
     (arith-test-case name #f value expected))
    ((arith-test operator value name expected)
     (begin
       (arith-test-case name #f value expected)
       ((lambda (operator)
          (arith-test-case name #t value expected))
        operator)))))      

(define (arith-test-case name closed? value expected)
  (set! *tests-run* (+ *tests-run* 1))
  (if (= value expected)
    (begin
      (write-string "  Success: ")
      (write-string name)
      (if closed? (write-string "  (closed)"))
      (newline))
    (begin
      (set! *failures* (+ *failures* 1))
      (write-string "  Failure: ")      
      (write-string name)
      (if closed? (write-string "  (closed)"))
      (write-string " = ")
      (write-number value)
      (write-string " and not ")
      (write-number expected)
      (newline))))

; Check if the result is #t or #f
;
(define-syntax bool-test
  (syntax-rules ()
    ((bool-test value name expected)
     (bool-test-case name #f value expected))
    ((bool-test operator value name expected)
     (begin
       (bool-test-case name #f value expected)
       ((lambda (operator)
          (bool-test-case name #t value expected))
        operator)))))

(define (bool-test-case name closed? value expected)
  (set! *tests-run* (+ *tests-run* 1))
  (if (eq? value expected)
    (begin
      (write-string "  Success: ")
      (write-string name)
      (if closed? (write-string "  (closed)"))
      (newline))
    (begin
      (set! *failures* (+ 1 *failures*))
      (write-string "  Failure: ")
      (write-string name)
      (if closed? (write-string "  (closed)"))
      (write-string " => ")
      (write-string (if expected "#t" "#f"))
      (newline))))

; Call a thunk and check if it returns #t
;
(define-syntax thunk-test
  (syntax-rules ()
    ((thunk-test name thunk)
     (thunk-test-case name #f thunk))
    ((thunk-test operator name thunk)
     (begin
       (thunk-test-case name #f thunk)
       ((lambda (operator)
          (thunk-test-case name #t thunk))
        operator)))))    

(define (thunk-test-case name closed? thunk)
  (set! *tests-run* (+ *tests-run* 1))
  (if (eq? (thunk) #t)
    (begin
      (write-string "  Success: ")
      (write-string name)
      (if closed? (write-string "  (closed)"))
      (newline))
    (begin
      (set! *failures* (+ 1 *failures*))
      (write-string "  Failure: ")
      (write-string name)
      (if closed? (write-string "  (closed)"))
      (newline))))
 
; Setup an exception handler and call thunk. Success is if thunk returns #t
;
(define-syntax exception-test
  (syntax-rules ()
    ((exception-test name opcode handler thunk)
     (exception-test-case name #f opcode handler thunk))
    ((exception-test operator name opcode handler thunk)
     (begin
       (exception-test-case name #f opcode handler thunk)
       ((lambda (operator)
          (exception-test-case name #t opcode handler thunk))
        operator)))))    

; execute expr and succeed if this raised an exception for opcode
;
(define-syntax exception-raise-test
  (syntax-rules ()
    ((exception-raise-test expr name opcode)
     (let ((fired? #f))
       (exception-test name opcode 
         (lambda (opcode-arg reason . arg) (set! fired? #t))
         (lambda () expr fired?))))
    ((exception-raise-test operator expr name opcode)
     (let ((fired? #f))
       (exception-test operator name opcode 
         (lambda (opcode-arg reason . arg) (set! fired? #t))
         (lambda () (set! fired? #f) expr fired?)))))) ; need to reset fired? to #f for the closed-compiled test  

(define (exception-test-case name closed? opcode handler thunk)
  (set! *tests-run* (+ *tests-run* 1))
  (if (eq? (call-with-exception-handler opcode handler thunk) #t)
    (begin
      (write-string "  Success: ")
      (write-string name)
      (if closed? (write-string "  (closed)"))
      (newline))
    (begin
      (set! *failures* (+ 1 *failures*))
      (write-string "  Failure: ")
      (write-string name)
      (if closed? (write-string "  (closed)"))
      (newline))))
 

(define (report-results)  
  (newline)
  (write-string "------------------------------ Results ------------------------------")
  (newline)
  (newline)
  (write-string "          Tests total: ")
  (write-number *tests-run*)
  (newline)
  (write-string "             Failures: ")   
  (write-number *failures*)
  (newline)
  (if (> *exceptions* 0)
    (begin
      (write-string "  Uncaught exceptions: ")
      (write-number *exceptions*)
      (newline)))
  (newline)
  (if (= *failures* 0) 0 1))


(define (setup-system in out)
  (set! *default-input-port* in)
  (set! *default-output-port* out)    
  (set-exception-handlers! (default-exception-handlers))
  (newline))

; ----------------------------- minimalistic exception handling -------------------------

(define (call-with-exception-handler opcode handler thunk)
  (let ((handlers (default-exception-handlers)))
     (vector-set! handlers opcode handler)
     (set-exception-handlers! handlers)
     (let ((result (thunk)))
       (set-exception-handlers! (default-exception-handlers))
       result)))         
          
(define (default-exception-handlers)     
  ; Set no handler for trap, so we can use that to exit the VM execution from our normal exception handler
  (let ((handlers (make-vector (vector-length opcode-arg-specs) default-exception-handler)))
    (vector-set! handlers (enum op trap) #f)
    (vector-set! handlers (enum op channel-maybe-write) default-io-exception-handler)
    (vector-set! handlers (enum op channel-maybe-read) default-io-exception-handler)
    handlers))     

(define (default-exception-handler opcode reason . args)  
  (set! *exceptions* (+ 1 *exceptions*)) ; count uncaught exceptions
  (newline)
  (write-string "Exception: opcode = ")
  (write-string (symbol->string (enumerand->name opcode op)))
  (write-string ", reason = ")
  (write-string (symbol->string (enumerand->name reason exception)))
  (write-string ", args = ")
  (write args)
  (newline)
  (newline)
  
  ; if we cannot continue, raise a trap exception (which has no handler) 
  ; to abort the VM execution
  (if (= reason (enum exception illegal-exception-return))
      (trap 0)))
  
; If even the basic i/o opcodes fail, the above default handler
; will be useless, so use this as a last resort
;
(define (default-io-exception-handler opcode reason . args)
  (message (list "I/O-Exception: " opcode ", " reason)))

